home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
lisp
/
eulisp
/
feel0_89.lha
/
Feel
/
Modules
/
macros0.em
< prev
next >
Wrap
Lisp/Scheme
|
1993-07-15
|
5KB
|
204 lines
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; EuLisp Module - Copyright (C) Codemist and University of Bath 1990 ;;
;; ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Change Log:
;; Version 1.0
;;
(defmodule macros0
(init others)
()
;; The compiler syntax is a little different...
(deflocal *defs-compile-time* ())
(defun compile-time-p ()
*defs-compile-time*)
((setter setter) compile-time-p
(lambda (x) (setq *defs-compile-time* x)))
(export compile-time-p)
(defmacro compile-time forms
(if (compile-time-p)
`(progn ,@forms)
nil))
(defmacro interpret-time forms
(if (compile-time-p)
nil
`(progn ,@forms)))
(export compile-time interpret-time)
(defmacro method-lambda (args . junk)
`(lambda ,(append (method-extra-args) args) ,@junk))
(defun method-extra-args ()
(if (compile-time-p)
()
(list '***method-status-handle*** '***method-args-handle***)))
(export method-lambda)
;; Control Extentions - Conditional Extentions
(defmacro cond b
(if b (if (cdr (car b)) (list 'if (car (car b)) (cons 'progn (cdr (car b)))
(cons 'cond (cdr b)))
(list 'or (car (car b)) (cons 'cond (cdr b))))
()))
;; Control Extentions - Binding extentions
;; LET expands to LAMBDA
(defmacro let args
(if (symbolp (car args))
(cons 'labels
(cons `(( ,(car args) ,(\@letvars (car (cdr args)))
,@(cddr args)))
`(,(car args) ,@(\@letforms (car (cdr args))))))
(cons (cons 'lambda (cons (\@letvars (car args)) (cdr args)))
(\@letforms (car args)))))
(defun \@letvars (b)
(if b (cons (car (car b)) (\@letvars (cdr b)))
()))
(defun \@letforms (b)
(if b (cons (car (cdr (car b))) (\@letforms (cdr b)))
()))
;; LET* expands to LET
(defmacro let* (bind . body)
(if bind (list 'let (cons (car bind) ())
(cons 'let* (cons (cdr bind) body)))
(cons 'progn body)))
;; LABELS is a complex LET
(defmacro labels (binds . body)
(cons 'let (cons (\@labelsvar binds) (\@labelsbody binds body))))
(defun \@labelsvar (b)
(if b (cons (list (car (car b)) ()) (\@labelsvar (cdr b)))
()))
(defun \@labelsbody (b body)
(if b (cons (list 'setq (car (car b)) (cons 'lambda (cdr (car b))))
(\@labelsbody (cdr b) body))
body))
(defmacro and b
(if b (if (cdr b) (list 'if (car b) (cons 'and (cdr b)) ())
(car b))
t))
(defmacro or b
(if b
(if (cdr b) (list 'let (list (list '\@ (car b)))
(list 'if '\@ '\@ (cons 'or (cdr b))))
(car b))
()))
(defmacro when (pred . forms) `(if ,pred (progn ,@forms) nil))
(defmacro unless (pred . forms) `(if ,pred nil (progn ,@forms)))
(export let let* cond and or when unless labels)
(defmacro unwind-protect (prot . rest)
`(fn-unwind-protect (lambda () ,prot)
(lambda () (progn ,@rest))))
(defmacro let/cc (name . forms)
`(simple-call/cc
(lambda (,name) ,@forms)))
(defmacro with-handler (fn . forms)
`(progn (push-handler ,fn)
(let ((@ (progn ,@forms)))
(pop-handler)
@)))
(export unwind-protect let/cc with-handler)
;; Control Extentions - Exit Extentions
(defmacro block forms (cons 'let/cc forms))
(defmacro return-from (name . forms)
(list name (cons 'progn forms)))
(export block return-from)
(defmacro catch (tag . body)
`(let/cc \@
(dynamic-let ((,tag \@)) ,@body)))
(defmacro throw (tag . forms)
`((dynamic ,tag) (progn ,@forms)))
(export catch throw)
(defmacro prog1 forms
`((lambda (@prog1-handle@)
,@(cdr forms)
@prog1-handle@) ,(car forms)))
(export prog1)
;
;; Multiple Values.
;;
;; An el-cheapo pseudo implementation.
;
;;(defmacro values forms
;;(if (null (cdr forms)) forms
;;`(list ,@forms)))
;;(defun call/mv (f values) (apply f values))
;;(defmacro let/mv (vars form . body)
;;`(call/mv (lambda ,vars ,@body) ,form))
;;(export values call/mv let/mv)
;; Compiler hacks
(defmacro compile-inline (n . x)
`(%Compiler-special inline-fn ,n ,@x))
(export compile-inline)
(defmacro compile-declare (bind name value)
`(%Compiler-special-object add-property
(,name ,value) ,bind))
(defmacro compile-add-callback (bind name value)
`(%Compiler-special-object add-callback
(,name ,value) ,bind))
(export compile-declare compile-add-callback)
;; Laziness
(defmacro define-simple-generic (name sig fn)
`(progn (defconstant ,name (make <generic-function>
'lambda-list ',sig
'argtype ,(list-length sig)
'name ',name
'method-class <method>))
(add-method ,name (make <method>
'signature (list ,@sig)
'function ,fn))
(export ,name)))
(export define-simple-generic)
)